home *** CD-ROM | disk | FTP | other *** search
/ Mac100% 1998 November / MAC100-1998-11.ISO.7z / MAC100-1998-11.ISO / ｵﾝﾗｲﾝｿﾌﾄ定点観測 / ﾕｰﾃｨﾘﾃｨ / Mops 3.2.sea / Mops 3.2 / Mops source / PPC source / qpCond < prev    next >
Text File  |  1998-06-06  |  18KB  |  796 lines
  1. (*                ============================
  2.  
  3.    Here we redefine various compiling and immediate words.
  4.    Note we load this file twice - we need the new definitions in 68k mode so we can
  5.    target compile the code generator, then after it's loaded we need the new
  6.    definitions in PPC mode.  We manage this with appropriate conditional compilation.
  7.    It's far better to do this with a single file rather than two files which could
  8.    easily get out of sync with each other.
  9.  
  10.                   ============================
  11. *)
  12.  
  13. forward  toObjPtr
  14.  
  15. : (")  { ¥ addr len -- }
  16.     & "  parse  -> len  -> addr
  17.     will_skip?  ?EXIT            ¥ no need to store the string if the
  18.                                 ¥  code won't be executed!
  19.     
  20.     len +C: const_data            ¥ put length byte in front for Pascal
  21.     const_data_ref                ¥ compile push of addr
  22.     len  postpone literal        ¥ compile push of len
  23.     addr len add: const_data    ¥ put string in const_data area
  24.     0 +C: const_data            ¥ add a zero at the end for C
  25. ;
  26.  
  27. PPC? not
  28. [IF]            ¥ in ppc mode, these are in zBase.
  29.  
  30. : "  { ¥ addr len -- }
  31.     PPC?
  32.     IF    state
  33.         IF        (")                        ¥ compiling
  34.         ELSE    & "  parse                ¥ interpreting
  35.         THEN
  36.     ELSE
  37.         postpone "
  38.     THEN
  39. ;            immediate
  40.  
  41.  
  42. : "S    postpone "  ;        immediate        ¥ ANSI synonym for "
  43.  
  44.  
  45. : ."  { ¥ addr len -- }
  46.     PPC?
  47.     IF    state
  48.         IF        (")                        ¥ compiling
  49.                 " type" evaluate        ¥  late bind so we get PPC 'type'
  50.         ELSE    & "  parse  type        ¥ interpreting
  51.         THEN
  52.     ELSE
  53.         postpone ."
  54.     THEN
  55. ;            immediate
  56.  
  57. : ABORT"
  58.     postpone "
  59.     " do_abq" evaluate        ¥ we need the PPC versions of this!
  60. ;        immediate
  61.  
  62.  
  63. (*    -> might be a bit more logical in qCreate, but that comes after
  64.     qCase which redefines SELECT[ etc. which we need here with its
  65.     old meaning.
  66.  
  67.     -> is similar to what was defined in Base, but if we're in the PPC
  68.     image we have to take special action for Values and Vects, since
  69.     they're stored differently on the PPC.
  70. *)
  71.  
  72. : ->
  73.     crossed? NIF  postpone ->  EXIT  THEN
  74.  
  75.     prfToken
  76.     SELECT[    objPtrTyp    ]=>  toObjPtr    EXIT
  77.           [    valTyp        ]=>  state NIF  2+ @abs  !        EXIT  THEN
  78.           [    vecTyp        ]=>  state NIF  2+  reloc!        EXIT  THEN
  79.  
  80.                 DEFAULT=>     drop
  81.     ]SELECT
  82.             
  83.     $ 60 ( opcode for store )  ,exec
  84. ;        immediate
  85.  
  86. [THEN]
  87.  
  88.  
  89. ¥    ====================== DO loops etc. ======================
  90.  
  91. (*
  92. Equalization of DO loops has a couple of entertaining features which add
  93. to life's rich tapestry:
  94.  
  95. 1.    I can be returned on the stack when the loop ends.  Since
  96.     I gets restored by the windup code, we have to do an equalization
  97.     first so that any reference to I on the stack gets converted to
  98.     a normal register.
  99.     
  100. 2.    LEAVE has to be handled properly - so before compiling the
  101.     branch, we have to equalize to whatever we'll have at the end
  102.     of the loop.
  103.     
  104. These considerations mean that we have to have something standard to
  105. equalize to at the end of the loop, and we might need to know this
  106. before we get there.  So we just pick something a bit arbitrary
  107. but sensible - using our return_cnt mechanism is probably as good
  108. as anything.
  109. *)
  110.  
  111.  
  112. ¥ I_reg            gpr  I        ¥ ###### MUST use while testing without loading
  113.                             ¥  setup etc.
  114.  
  115. (*    ?adjust_I_and_branch is called to handle the end of a DO or FOR loop, in the cases
  116.     where I gets a fixed increment.
  117.     If the ctr wasn't clobbered in the loop, we generate a bdnz for the branch, which
  118.     is faster than a test on I and then branch on condition.
  119.     Note though, that if the ctr was clobbered in the loop, this means there was an
  120.     inner loop or an external call, and in these situations the extra overhead is
  121.     insignificant.
  122. *)
  123.  
  124. : ?adjust_I_and_branch  { increment for? -- }
  125.         ¥ we only bother decrementing I if it's been used in the loop.
  126.  
  127.     I_reg select: GPRs
  128.     get: ivar> lastRefCDP in GPRs  loop_start u>=
  129.     ctr_clobbered? or
  130.     IF  increment postpone literal  " ++> i" evaluate  THEN
  131.  
  132.     ctr_clobbered?
  133.     IF    for?
  134.         IF    " i 0>=" evaluate
  135.         ELSE
  136.             " i do_limit" evaluate
  137.             increment 0>
  138.             IF        postpone <
  139.             ELSE    postpone >=
  140.             THEN
  141.         THEN
  142.         false pif
  143.     ELSE
  144.         $ 42000000 code,    ¥  bdnz
  145.     THEN
  146.     <resolve
  147.     true -> ctr_clobbered?        ¥ if it wasn't before, it is now!
  148. ;
  149.  
  150.  
  151. ppc? [if] hexx [else] hex [then]
  152.  
  153. : windup_loop  { flags for? restore_do_limit? RP_increment -- }
  154.  
  155.     BF050000  code,            ¥ LEAVEs resolve to here.  This pseudo-instrn
  156.                             ¥  allows resolution at finalization time.  Gets
  157.                             ¥  replaced by the first instruction of the windup
  158.                             ¥  sequence, namely:
  159.                             ¥        lwz        r21/I, (r17/RP)            restore I
  160.                             ¥ It doesn't matter that we may be doing another
  161.                             ¥  equalization before the rest of the windup
  162.                             ¥  sequence, since equalization doesn't affect
  163.                             ¥  r22 or the return stack.
  164.  
  165.                 ¥ now the rest of the windup sequence:
  166.  
  167.     restore_do_limit?        ¥                                    
  168.     IF    82D10004  code,        ¥ lwz       r22/do_limit, 4(r17/RP)      and do limit reg if nec
  169.     THEN
  170.     3A310000  RP_increment or
  171.                   code,        ¥ addi      r17/RP, r17/RP, incr    - adjust RP
  172. ¥ Note: RP_increment is now always 8.  We should get rid of this as a parameter.
  173.  
  174.     flags 8 and
  175.     IF    " else 2drop then"  evaluate
  176.     THEN
  177.     
  178.     for?
  179.     IF    " else drop then"  evaluate
  180.     THEN
  181. ;
  182.  
  183.  
  184. ¥ I'll define UNLOOP and UNFOR here, since they're very similar to the above, but
  185. ¥  simpler.  We assume I is getting used and restore it (it may not have been
  186. ¥  used in the loop yet, but may before the end).
  187.  
  188. : UNLOOP
  189.     get_loop_cnts  simple_equalize    ¥ since a ref to I might be on the stack,
  190.                                     ¥  and we're about to clobber it!
  191.  
  192.     82D10004  code,            ¥ lwz       r22/do_limit, 4(r17/RP)      and do limit reg
  193.     82B10000  code,            ¥ lwz       r21/I, (r17/RP)              and I
  194.     3A310008  code,            ¥ addi      r17/RP, r17/RP, 8        - adjust RP
  195. ;
  196. ppc? [if] ppc_immediate [else] immediate [then]
  197.  
  198. : UNFOR
  199.     get_loop_cnts  simple_equalize    ¥ since a ref to I might be on the stack,
  200.                                     ¥  and we're about to clobber it!
  201.  
  202.     82B10000  code,            ¥ lwz       r21/I, (r17/RP)              and I
  203.     3A310008  code,            ¥ addi      r17/RP, r17/RP, 8        - adjust RP
  204. ;
  205. ppc? [if] ppc_immediate [else] immediate [then]
  206.  
  207.  
  208. ppc? [if] decimalx [else] decimal [then]
  209.  
  210.  
  211. : (WHILE)  { x1 Nwhile? ¥ svCS svCF -- x1 }
  212.  
  213.     pop: control_stk  -> svCS  pop: control_flags -> svCF
  214.     restore: fcstk_temp  restore: cstk_temp
  215.     Nwhile? IF " nif" ELSE " if" THEN  evaluate
  216.     save: cstk_temp  save: fcstk_temp
  217.     svCF push: control_flags  svCS push: control_stk
  218.     x1  ;
  219.  
  220.  
  221. ppc?
  222. [IF]
  223.  
  224. : IF        true pif  >mark  ;        ppc_immediate
  225.  
  226. : NIF        false pif  >mark  ;        ppc_immediate
  227.  
  228. : ELSE        (else)  ;                ppc_immediate
  229.  
  230. : THEN        >resolve&equalize  ;    ppc_immediate
  231.  
  232. : BEGIN        <mark  ;                ppc_immediate
  233.     
  234. : WHILE        false (while)  ;        ppc_immediate
  235.  
  236. : NWHILE    true (while)  ;            ppc_immediate
  237.  
  238. : UNTIL        true pif  <resolve  ;    ppc_immediate
  239.  
  240. : NUNTIL    false pif  <resolve  ;    ppc_immediate
  241.     
  242. : AGAIN        $ BF080000 code,  <resolve  ;        ppc_immediate
  243.     
  244. : REPEAT    ( postpone again  postpone then )    ¥ AGAIN and THEN *must* be ppc_immediate,
  245.                                                 ¥  so we can't see them to call them!
  246.         $ BF080000 code,  <resolve   >resolve&equalize  ;        ppc_immediate
  247.  
  248. [ELSE]
  249.  
  250. : IF    ppc?
  251.         IF        true pif  >mark
  252.         ELSE    postpone if
  253.         THEN
  254. ;                                    immediate
  255.  
  256. : NIF    ppc?
  257.         IF        false pif  >mark
  258.         ELSE    postpone nif
  259.         THEN
  260. ;                                    immediate
  261.  
  262. : ELSE    ppc?
  263.         IF        (else)
  264.         ELSE    postpone else
  265.         THEN
  266. ;                                    immediate
  267.  
  268. : THEN    ppc?
  269.         IF        >resolve&equalize
  270.         ELSE    postpone then
  271.         THEN
  272. ;                                    immediate
  273.  
  274.  
  275. : BEGIN        ppc?
  276.             IF        <mark
  277.             ELSE    postpone begin
  278.             THEN
  279. ;                                    immediate
  280.     
  281. : WHILE        ppc? 
  282.             IF        false (while)
  283.             ELSE    postpone while
  284.             THEN
  285. ;                                    immediate
  286.  
  287. : NWHILE    ppc? 
  288.             IF        true (while)
  289.             ELSE    postpone nwhile
  290.             THEN
  291. ;                                    immediate
  292.  
  293. : UNTIL        ppc?
  294.             IF        true pif  <resolve
  295.             ELSE    postpone until
  296.             THEN
  297. ;                                    immediate
  298.  
  299. : NUNTIL    ppc?
  300.             IF        false pif  <resolve
  301.             ELSE    postpone nuntil
  302.             THEN
  303. ;                                    immediate
  304.     
  305. : AGAIN        ppc?
  306.             IF        $ BF080000 code,
  307.                     <resolve
  308.             ELSE
  309.                     postpone again
  310.             THEN
  311. ;                                    immediate
  312.     
  313. : REPEAT    ppc?
  314.             IF        postpone again
  315.                     postpone then
  316.             ELSE
  317.                     postpone repeat
  318.             THEN
  319. ;                                    immediate
  320.  
  321. [THEN]
  322.  
  323.  
  324. ¥ For FOR loops, we initially copy i to the ctr then decrement i.  At NEXT,
  325. ¥  we decrement i and branch back on the ctr being nonzero, unless it was
  326. ¥  clobbered in the loop.
  327.  
  328. : FOR
  329.     " dup 0> if"  evaluate            ¥ we always include a neg/zero bailout test here
  330.     " i >r -> i"  evaluate
  331.     i_reg gpr>ctr
  332.     " -1 ++> i"  evaluate
  333.     <mark
  334.     false -> ctr_clobbered?
  335. ;        
  336. ppc? [if] ppc_immediate [else] immediate [then]
  337.  
  338. : NEXT
  339.     -1 true ?adjust_I_and_branch
  340.     false true false 8  windup_loop
  341. ;
  342. ppc? [if] ppc_immediate [else] immediate [then]
  343.  
  344.  
  345. ppc?
  346. [IF]
  347.  
  348. : DO        ¥ ( limit init-index -- )
  349.     " do_limit >rw i >rw -> i -> do_limit do_limit i -"  evaluate
  350.     0 push: control_flags            ¥ tell LOOP there's no test to resolve
  351.     0 push: control_stk                ¥ dummy
  352.     1 operands  gpr: opnd1 gpr>ctr
  353.     free: opnd1
  354.     <mark
  355.     false -> ctr_clobbered?  ;        ppc_immediate
  356.  
  357.  
  358. : ?DO
  359.     " 2dup - -> treg treg 0> if"  evaluate
  360.     " do_limit >rw i >rw -> i -> do_limit" evaluate
  361.     8 push: control_flags            ¥ tell LOOP there's a test to resolve
  362.     0 push: control_stk                ¥ dummy
  363. ¥    1 operands  gpr: opnd1 gpr>ctr
  364.     0 gpr>ctr
  365.     free: opnd1
  366.     <mark
  367.     false -> ctr_clobbered?  ;        ppc_immediate
  368.  
  369.  
  370. : LOOP
  371.     1 false ?adjust_I_and_branch
  372.     pop: control_stk drop
  373.     pop: control_flags false true 8 windup_loop  ;    ppc_immediate
  374.  
  375.  
  376. : +LOOP
  377.     " dup ++> i i do_limit rot 0>= if < else >= then"  evaluate
  378.     false pif
  379.     <resolve
  380.     pop: control_stk drop
  381.     pop: control_flags false true 8 windup_loop  ;    ppc_immediate
  382.  
  383. [ELSE]
  384.  
  385. : DO        ¥ ( limit init-index -- )
  386.     PPC?
  387.     IF    " do_limit >rw i >rw -> i -> do_limit do_limit i -"  evaluate
  388.         0 push: control_flags            ¥ tell LOOP there's no test to resolve
  389.         0 push: control_stk                ¥ dummy
  390.         1 operands  gpr: opnd1 gpr>ctr
  391.         free: opnd1
  392.         <mark
  393.         false -> ctr_clobbered?
  394.     ELSE
  395.         postpone do
  396.     THEN  ;                            immediate
  397.  
  398.  
  399. : ?DO
  400.     PPC?
  401.     IF    " 2dup - -> treg treg 0> if"  evaluate
  402.         " do_limit >rw i >rw -> i -> do_limit" evaluate
  403.         8 push: control_flags            ¥ tell LOOP there's a test to resolve
  404.         0 push: control_stk                ¥ dummy
  405.         0 gpr>ctr
  406.         free: opnd1
  407.         <mark
  408.         false -> ctr_clobbered?
  409.     ELSE
  410.         postpone ?do
  411.     THEN  ;                            immediate
  412.  
  413.  
  414. : LOOP
  415.     PPC?
  416.     IF    1 false ?adjust_I_and_branch
  417.         pop: control_stk drop
  418.         pop: control_flags false true 8 windup_loop
  419.     ELSE
  420.         postpone loop
  421.     THEN
  422. ;                                    immediate
  423.  
  424.  
  425. : +LOOP
  426.     PPC?
  427.     IF    " dup ++> i i do_limit rot 0>= if < else >= then"  evaluate
  428.         false pif
  429.         <resolve
  430.         pop: control_stk drop
  431.         pop: control_flags false true 8 windup_loop
  432.     ELSE
  433.         postpone +loop
  434.     THEN
  435. ;                                        immediate
  436.  
  437. [THEN]
  438.  
  439. : LEAVE        ¥ we use a pseudo-op, and resolve during finalization.
  440.     get_loop_cnts  simple_equalize    ¥ first we must equalize to the
  441.                                     ¥  loop end since we're branching 
  442.                                     ¥  there.
  443.      $ BF040000  code,
  444.  ;
  445. ppc? [if] ppc_immediate [else] immediate [then]
  446.  
  447.  
  448. ¥ these redefinitions have to be left to the end since the originals
  449. ¥  get used...
  450.  
  451. (* Tick on the PPC will return the addr of the byte following the handler
  452.    field, as on the 68k.  This isn't 4-byte aligned on the PPC, but in
  453.    lots of places we do ['] something 2- w@  to get the handler code,
  454.    so we'll stick with it.
  455.  
  456.    We need to be very careful about ticking something that isn't code.
  457.    ANSI rightly says that this is undefined, but I think I've done it
  458.    in various places in the Mops code, e.g. to get a data address.  This
  459.    will be invalid on the PPC, and may cause nasty bugs, so I want to
  460.    be sure I catch these situations.
  461.    
  462.    On the PPC we can always distinguish code from non-code definitions
  463.    - the latter have handler codes BCxx.  So I now make ['] do a check,
  464.    and give an error on words with BCxx, except for the few exceptions
  465.    such as vectors, for which ticking is legal.
  466.    
  467.    I've provided <'> as a version of ['] that omits the check, so that 
  468.    I can do it if I know it's OK.
  469.    
  470.    Seeing we're looking at the handler code anyway when we tick, we
  471.    might as well simplfy :proc words by automatically picking up the
  472.    UPP address if we're running on the PPC.
  473.  
  474. *)
  475.  
  476. ppc?
  477. [IF]
  478.  
  479. : '  ( -- xt )
  480.     defined? ?notfound  ;
  481.  
  482.  
  483. : [']  { ¥ hdlr -- xt }
  484.  
  485.     '
  486.     dup 2- w@ -> hdlr
  487.  
  488. ¥ Normally we won't allow ticking of BC words, but we need to
  489. ¥  allow a few of them for which EXECUTEing an xt makes sense.
  490. ¥ This means that EXECUTE (in Setup) must special-case each of 
  491. ¥  these.
  492.  
  493.     hdlr 8 >>  $ BC =  
  494.     IF
  495.         hdlr
  496.         CASE[    $ BC1D    ]=>            ¥ class_h
  497. ¥            [    $ BC02    ]=>            ¥ const_h
  498.             [    $ BC05    ]=>            ¥ vect_h
  499.             [    $ BC0C    ]=>            ¥ does_h
  500.             [    $ BC41    ]=>            ¥ marker_h
  501.  
  502.             DEFAULT=>    215 die        ¥ "can't tick that kind of word"
  503.         ]CASE
  504.     THEN
  505.     lit_addr
  506.     
  507.     hdlr $ BE04 =
  508.     IF                ¥ it's a :proc word - replace xt with UPP
  509.         " 2+ @abs @"  evaluate
  510.     THEN
  511. ;                                ppc_immediate
  512.  
  513.  
  514. : <'>    '  lit_addr  ;            ppc_immediate
  515.  
  516.  
  517. (*
  518. -> (immediate, compilation only) compiles a store to a value
  519. or a vect by passing the otStore opcode to its compilation handler.
  520. This is an interim scheme until  -> is redefined in zArgs.
  521. *)
  522.  
  523. : ->
  524.     ?comp
  525.     '  otStore (compN)  ;        ppc_immediate
  526.  
  527. : ++>
  528.     ?comp
  529.     '  otAdd  (compN)  ;        ppc_immediate
  530.  
  531.  
  532. (* For forward definitions, we can't tell how many parms we'll need in
  533.    regs, or how many results there are.  So we just assume there are no
  534.    named parms/results (which will lead to call_cnt cells being in regs),
  535.    and 1 result.  We then work to this specification when the forward
  536.    definition is resolved.
  537. *)
  538.  
  539. : unresolved
  540.     r@ 6 - .id
  541.     109 die
  542. ;
  543.  
  544.  
  545. : FORWARD
  546.     ppc_header
  547.     $ BE010100  code,    ¥ $ BE01 = forward defn
  548.                         ¥ $ 0100 = 0 flags, 1 = 1 stk result,
  549.                         ¥ 0 = no named parms, 0 = zero total parms/locals
  550.  
  551.     ['] unresolved 2+  CDP -  $ 03FFFFFF and  $ 48000001 or  code,
  552. ;                    ppc_only
  553.  
  554. : :F
  555.     '  2+  -> ^fwd
  556.     CDP -> const_data_start
  557.     $ BF060000  code,
  558.     true ppc_entry
  559.     fwd_gpr_rtn_cnt  -> gpr_rtn_cnt
  560.     fwd_fpr_rtn_cnt  -> fpr_rtn_cnt
  561.     drop 301
  562. ;                    ppc_only
  563.  
  564. : ;F
  565.     301 ?defn
  566.     curr-def 2- (;)            ¥ similar to "postpone ;" which we can't do here
  567.     ^fwd  curr-def  resolve_unconditional_branch
  568. ;                    ppc_immediate
  569.  
  570.  
  571. [ELSE]
  572.  
  573. : [']    ppc?
  574.         IF    '
  575.  
  576. ¥ should I allow ticking of BC words?  I first thought not, but it's
  577. ¥  useful to be able to tick a couple of them which are safe.
  578.  
  579.             dup 2- c@  $ BC =  
  580.             IF
  581.                 dup 2- w@
  582.                 CASE[    $ BC1D    ]=>            ¥ class_h
  583.                     [    $ BC02    ]=>            ¥ const_h
  584.                     [    $ BC05    ]=>            ¥ vect_h
  585.                     [    $ BC0C    ]=>            ¥ does_h
  586.  
  587.                     DEFAULT=>    215 die        ¥ "can't tick that kind of word"
  588.                 ]CASE
  589.             THEN
  590.             lit_addr
  591.         ELSE
  592.             postpone [']
  593.         THEN
  594. ;                                immediate
  595.  
  596. : <'>
  597.         ppc?
  598.         IF        '  lit_addr
  599.         ELSE    postpone [']
  600.         THEN
  601. ;                                immediate
  602.  
  603.  
  604.  
  605. (* For forward definitions, we can't tell how many parms we'll need in
  606.    regs, or how many results there are.  So we just assume there are no
  607.    named parms/results (which will lead to call_cnt cells being in regs),
  608.    and 1 result.  We then work to this specification when the forward
  609.    definition is resolved.
  610. *)
  611.  
  612.  
  613. : FORWARD
  614.     ppc?
  615.     IF    ppc_header
  616.         $ BE010100  code,    ¥ $ BE01 = forward defn
  617.                             ¥ $ 0100 = 0 flags, 1 = 1 stk result,
  618.                             ¥ 0 = no named parms, 0 = zero total parms/locals
  619.         $ 48000000  code,
  620.     ELSE
  621.         forward
  622.     THEN
  623. ;
  624.  
  625. : :F
  626.     ppc?
  627.     IF    '  2+  -> ^fwd
  628.         CDP -> const_data_start
  629.         $ BF060000  code,
  630.         true ppc_entry
  631.         fwd_gpr_rtn_cnt  -> gpr_rtn_cnt
  632.         fwd_fpr_rtn_cnt  -> fpr_rtn_cnt
  633.         drop 301
  634.     ELSE
  635.         :f
  636.     THEN
  637. ;
  638.  
  639. : ;F
  640.     ppc?
  641.     IF    301 ?defn  300  postpone ;
  642.         ^fwd curr-def  resolve_unconditional_branch
  643.     ELSE
  644.         postpone ;f
  645.     THEN
  646. ;                            immediate
  647.  
  648.  
  649. : +ECHOx    +echo  ;    ¥ so I can redefine +ECHO and still be able to call the
  650.                         ¥  68k one
  651. : -ECHOx    -echo  ;
  652.  
  653. [THEN]
  654.  
  655. ppc?
  656. [IF]
  657.  
  658. : >R    true  (>r)  ;            ppc_immediate
  659. : R>    true  (r>)  ;            ppc_immediate
  660. : >RW    false (>r)  ;            ppc_immediate
  661. : R>W    false (r>)  ;            ppc_immediate
  662.  
  663. : R@  ( -- n )        ¥ We handle this as a normal fetch using RP as the
  664.                     ¥  base, with a zero displacement.  But note that
  665.                     ¥  we mustn't hoist this fetch past any change of
  666.                     ¥  RP.  Since we don't record changes to RP, we just
  667.                     ¥  don't hoist at all.  R@ is so rare that it's not
  668.                     ¥  worth doing anything beyond this simple approach.
  669.  
  670.     hoist?  false -> hoist?        ¥ mustn'
  671.     postpone RP  postpone @
  672.     ( false -> leaf? )
  673.     -> hoist?
  674. ;                            ppc_immediate
  675.  
  676. (*    The idea of the "false -> leaf?" was, that if we're in a leaf
  677.     proc, the return addr isn't on the return stack, and this might
  678.     break some code that tries to access the rtn addr with rtn stack
  679.     operations.  But this sort of monkeying with the rtn addr is highly
  680.     nonstandard, and would never work anyway if there are locals, so
  681.     we're not going to support it.
  682. *)
  683.  
  684.  
  685.  
  686. [ELSE]
  687.  
  688. : >R    ppc?
  689.         IF    true (>r)
  690.         ELSE
  691.             postpone >r
  692.         THEN
  693. ;                            immediate
  694.  
  695. : R>    ppc?
  696.         IF    true (r>)
  697.         ELSE
  698.             postpone r>
  699.         THEN
  700. ;                            immediate
  701.  
  702. ¥ These 2 are only used when PPC? is true.
  703.  
  704. : >RW    false (>r)  ;        immediate
  705. : R>W    false (r>)  ;        immediate
  706.  
  707.  
  708. : R@    ppc?
  709.         IF
  710.             hoist?  false -> hoist?
  711.             postpone RP  postpone @
  712.             ( false -> leaf? )
  713.             -> hoist?
  714.         ELSE
  715.             postpone r@
  716.         THEN
  717. ;                            immediate
  718.  
  719. [THEN]
  720.  
  721. 0    gpr  TREG            ¥ can't redefine this till after all 68k-style
  722.                         ¥  SELECT[ and CASE[ !!
  723.  
  724.  
  725. ¥ In this system, compilation is done by executing the compilation handler
  726. ¥ for the word in question.  POSTPONE must therefore be immediate, and
  727. ¥ compile the right code into the client definition.  This code consists
  728. ¥ of a literal push of the POSTPONEd word's cfa, then a call to (COMP).
  729.  
  730. ppc?
  731. [IF]
  732.  
  733. : POSTPONE
  734.     defined?
  735.     dup 0<
  736.     IF                ¥ not immediate - compile code to compile it
  737.         drop  
  738.         lit_addr
  739.         postpone (comp)
  740.  
  741.     ELSE
  742.         0> IF        ¥ immediate - compile it now
  743.             (comp)
  744.         ELSE
  745.             0  ?notFound    ¥ force a "not found" error
  746.         THEN
  747.     THEN
  748. ;                ppc_immediate
  749.  
  750.  
  751. marker m__zcase
  752. endload
  753.  
  754. [ELSE]
  755.  
  756. : POSTPONE
  757.     ppc?
  758.     IF    defined?
  759.         dup 0<
  760.         IF                ¥ not immediate - compile code to compile it
  761.             drop lit_addr " (comp)" evaluate
  762.                                     ¥ PPC (comp) not defined yet!
  763.         ELSE
  764.             0> IF        ¥ immediate - compile it now
  765.                 (comp)
  766.             ELSE
  767.                 0  ?notFound    ¥ force a "not found" error
  768.             THEN
  769.         THEN
  770.     ELSE
  771.         postpone postpone
  772.     THEN
  773. ;                immediate
  774.  
  775.  
  776. (*    When target compiling, we use the $20 bit in the length byte of the
  777.     header, to tell the 68k FIND that we don't want to find these words
  778.     on the 68k.  But they'll be found by the PPC FIND, since it won't look
  779.     at this bit.  This is vital for handling words like IF in a sensible
  780.     manner.
  781.     
  782.     We invoke this feature by using ppc_only or ppc_immediate, similarly
  783.     to immediate (i.e. straight after the definition it applies to).
  784.     
  785.     We make these words immediate so we can use them within the defn
  786.     itself - e.g. in the defn for ; we have to specify it as ppc_immediate
  787.     before we hit its final ; for obvious reasons!
  788. *)
  789.  
  790. : PPC_ONLY                ¥ sets PPC-only bit
  791.     $ 20  latest  cset  ;    immediate
  792.  
  793. : PPC_IMMEDIATE            ¥ sets immediate and PPC-only bits
  794.     $ 60  latest  cset  ;    immediate
  795.  
  796. [THEN]